home *** CD-ROM | disk | FTP | other *** search
/ CrystalVision Software Se… Wiki Wonder - Wikipedia / CrystalVision Software Services 703: The Wiki Wonder - Wikipedia.iso / 0703 / Educate / Complete Calc / Setup.exe / lib / tcl / init.tcl < prev    next >
Encoding:
Text File  |  2006-10-25  |  11.5 KB  |  509 lines
  1.  
  2. if {[info commands package] == ""} {
  3. error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
  4. }
  5. package require -exact Tcl 8.4
  6.  
  7.  
  8. if {![info exists auto_path]} {
  9. if {[info exists env(TCLLIBPATH)]} {
  10. set auto_path $env(TCLLIBPATH)
  11. } else {
  12. set auto_path ""
  13. }
  14. }
  15. namespace eval tcl {
  16. variable Dir
  17. if {[info library] ne ""} {
  18. foreach Dir [list [info library] [file dirname [info library]]] {
  19. if {[lsearch -exact $::auto_path $Dir] < 0} {
  20. lappend ::auto_path $Dir
  21. }
  22. }
  23. }
  24. set Dir [file join [file dirname [file dirname  [info nameofexecutable]]] lib]
  25. if {[lsearch -exact $::auto_path $Dir] < 0} {
  26. lappend ::auto_path $Dir
  27. }
  28. if {[info exists ::tcl_pkgPath]} {
  29. foreach Dir $::tcl_pkgPath {
  30. if {[lsearch -exact $::auto_path $Dir] < 0} {
  31. lappend ::auto_path $Dir
  32. }
  33. }
  34. }
  35. }
  36.  
  37.  
  38. if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
  39. namespace eval tcl {
  40. proc EnvTraceProc {lo n1 n2 op} {
  41. set x $::env($n2)
  42. set ::env($lo) $x
  43. set ::env([string toupper $lo]) $x
  44. }
  45. proc InitWinEnv {} {
  46. global env tcl_platform
  47. foreach p [array names env] {
  48. set u [string toupper $p]
  49. if {$u ne $p} {
  50. switch -- $u {
  51. COMSPEC -
  52. PATH {
  53. if {![info exists env($u)]} {
  54. set env($u) $env($p)
  55. }
  56. trace add variable env($p) write  [namespace code [list EnvTraceProc $p]]
  57. trace add variable env($u) write  [namespace code [list EnvTraceProc $p]]
  58. }
  59. }
  60. }
  61. }
  62. if {![info exists env(COMSPEC)]} {
  63. if {$tcl_platform(os) eq "Windows NT"} {
  64. set env(COMSPEC) cmd.exe
  65. } else {
  66. set env(COMSPEC) command.com
  67. }
  68. }
  69. }
  70. InitWinEnv
  71. }
  72. }
  73.  
  74.  
  75. package unknown tclPkgUnknown
  76.  
  77. if {![interp issafe]} {
  78. if {$::tcl_platform(platform) eq "unix"
  79. && $::tcl_platform(os) eq "Darwin"} {
  80. package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
  81. }
  82. if {$::tcl_platform(platform) eq "macintosh"} {
  83. package unknown [list tcl::MacPkgUnknown [package unknown]]
  84. }
  85. }
  86.  
  87.  
  88. if {[namespace which -command exec] eq ""} {
  89.  
  90.  
  91. set auto_noexec 1
  92. }
  93. set errorCode ""
  94. set errorInfo ""
  95.  
  96.  
  97. if {[namespace which -command tclLog] eq ""} {
  98. proc tclLog {string} {
  99. catch {puts stderr $string}
  100. }
  101. }
  102.  
  103.  
  104. proc unknown args {
  105. global auto_noexec auto_noload env unknown_pending tcl_interactive
  106. global errorCode errorInfo
  107.  
  108.  
  109. set cmd [lindex $args 0]
  110. if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
  111. set arglist [lrange $args 1 end]
  112. set ret [catch {uplevel 1 ::$cmd $arglist} result]
  113. if {$ret == 0} {
  114. return $result
  115. } else {
  116. return -code $ret -errorcode $errorCode $result
  117. }
  118. }
  119.  
  120.  
  121. if {![info exists errorCode]} {
  122. set errorCode ""
  123. }
  124. if {![info exists errorInfo]} {
  125. set errorInfo ""
  126. }
  127. set savedErrorCode $errorCode
  128. set savedErrorInfo $errorInfo
  129. set name $cmd
  130. if {![info exists auto_noload]} {
  131. if {[info exists unknown_pending($name)]} {
  132. return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  133. }
  134. set unknown_pending($name) pending;
  135. set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
  136. unset unknown_pending($name);
  137. if {$ret != 0} {
  138. append errorInfo "\n    (autoloading \"$name\")"
  139. return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
  140. }
  141. if {![array size unknown_pending]} {
  142. unset unknown_pending
  143. }
  144. if {$msg} {
  145. set errorCode $savedErrorCode
  146. set errorInfo $savedErrorInfo
  147. set code [catch {uplevel 1 $args} msg]
  148. if {$code ==  1} {
  149. set cinfo $args
  150. set ellipsis ""
  151. while {[string bytelength $cinfo] > 150} {
  152. set cinfo [string range $cinfo 0 end-1]
  153. set ellipsis "..."
  154. }
  155. append cinfo $ellipsis "\"\n    (\"uplevel\" body line 1)"
  156. append cinfo "\n    invoked from within"
  157. append cinfo "\n\"uplevel 1 \$args\""
  158. set expect "$msg\n    while executing\n\"$cinfo"
  159. if {$errorInfo eq $expect} {
  160. return -code error -errorcode $errorCode $msg
  161. }
  162. set expect "\n    invoked from within\n\"$cinfo"
  163. set exlen [string length $expect]
  164. set eilen [string length $errorInfo]
  165. set i [expr {$eilen - $exlen - 1}]
  166. set einfo [string range $errorInfo 0 $i]
  167. if {$errorInfo ne "$einfo$expect"} {
  168. error "Tcl bug: unexpected stack trace in \"unknown\"" {}  [list CORE UNKNOWN BADTRACE $expect $errorInfo]
  169. }
  170. return -code error -errorcode $errorCode  -errorinfo $einfo $msg
  171. } else {
  172. return -code $code $msg
  173. }
  174. }
  175. }
  176.  
  177. if {([info level] == 1) && [info script] eq ""  && [info exists tcl_interactive] && $tcl_interactive} {
  178. if {![info exists auto_noexec]} {
  179. set new [auto_execok $name]
  180. if {$new ne ""} {
  181. set errorCode $savedErrorCode
  182. set errorInfo $savedErrorInfo
  183. set redir ""
  184. if {[namespace which -command console] eq ""} {
  185. set redir ">&@stdout <@stdin"
  186. }
  187. return [uplevel 1 exec $redir $new [lrange $args 1 end]]
  188. }
  189. }
  190. set errorCode $savedErrorCode
  191. set errorInfo $savedErrorInfo
  192. if {$name eq "!!"} {
  193. set newcmd [history event]
  194. } elseif {[regexp {^!(.+)$} $name -> event]} {
  195. set newcmd [history event $event]
  196. } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
  197. set newcmd [history event -1]
  198. catch {regsub -all -- $old $newcmd $new newcmd}
  199. }
  200. if {[info exists newcmd]} {
  201. tclLog $newcmd
  202. history change $newcmd 0
  203. return [uplevel 1 $newcmd]
  204. }
  205.  
  206. set ret [catch {set candidates [info commands $name*]} msg]
  207. if {$name eq "::"} {
  208. set name ""
  209. }
  210. if {$ret != 0} {
  211. return -code $ret -errorcode $errorCode  "error in unknown while checking if \"$name\" is a unique command abbreviation:\n$msg"
  212. }
  213. if {$name eq ""} {
  214. if {[llength $candidates] != 1} {
  215. return -code error "empty command name \"\""
  216. }
  217. return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]]
  218. }
  219. set cmds [list]
  220. foreach x $candidates {
  221. if {[string first $name $x] == 0} {
  222. lappend cmds $x
  223. }
  224. }
  225. if {[llength $cmds] == 1} {
  226. return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
  227. }
  228. if {[llength $cmds]} {
  229. return -code error "ambiguous command name \"$name\": [lsort $cmds]"
  230. }
  231. }
  232. return -code error "invalid command name \"$name\""
  233. }
  234.  
  235.  
  236. proc auto_load {cmd {namespace {}}} {
  237. global auto_index auto_oldpath auto_path
  238.  
  239. if {$namespace eq ""} {
  240. set namespace [uplevel 1 [list ::namespace current]]
  241. }
  242. set nameList [auto_qualify $cmd $namespace]
  243. lappend nameList $cmd
  244. foreach name $nameList {
  245. if {[info exists auto_index($name)]} {
  246. namespace eval :: $auto_index($name)
  247. if {[namespace which -command $name] ne ""} {
  248. return 1
  249. }
  250. }
  251. }
  252. if {![info exists auto_path]} {
  253. return 0
  254. }
  255.  
  256. if {![auto_load_index]} {
  257. return 0
  258. }
  259. foreach name $nameList {
  260. if {[info exists auto_index($name)]} {
  261. namespace eval :: $auto_index($name)
  262. if {[namespace which -command $name] ne ""} {
  263. return 1
  264. }
  265. }
  266. }
  267. return 0
  268. }
  269.  
  270.  
  271. proc auto_load_index {} {
  272. global auto_index auto_oldpath auto_path errorInfo errorCode
  273.  
  274. if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} {
  275. return 0
  276. }
  277. set auto_oldpath $auto_path
  278.  
  279.  
  280. set issafe [interp issafe]
  281. for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  282. set dir [lindex $auto_path $i]
  283. set f ""
  284. if {$issafe} {
  285. catch {source [file join $dir tclIndex]}
  286. } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
  287. continue
  288. } else {
  289. set error [catch {
  290. set id [gets $f]
  291. if {$id eq "# Tcl autoload index file, version 2.0"} {
  292. eval [read $f]
  293. } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
  294. while {[gets $f line] >= 0} {
  295. if {[string index $line 0] eq "#"
  296. || ([llength $line] != 2)} {
  297. continue
  298. }
  299. set name [lindex $line 0]
  300. set auto_index($name)  "source [file join $dir [lindex $line 1]]"
  301. }
  302. } else {
  303. error "[file join $dir tclIndex] isn't a proper Tcl index file"
  304. }
  305. } msg]
  306. if {$f ne ""} {
  307. close $f
  308. }
  309. if {$error} {
  310. error $msg $errorInfo $errorCode
  311. }
  312. }
  313. }
  314. return 1
  315. }
  316.  
  317.  
  318. proc auto_qualify {cmd namespace} {
  319.  
  320. set n [regsub -all {::+} $cmd :: cmd]
  321.  
  322.  
  323.  
  324. if {[string match ::* $cmd]} {
  325. if {$n > 1} {
  326. return [list $cmd]
  327. } else {
  328. return [list [string range $cmd 2 end]]
  329. }
  330. }
  331.  
  332.  
  333. if {$n == 0} {
  334. if {$namespace eq "::"} {
  335. return [list $cmd]
  336. } else {
  337. return [list ${namespace}::$cmd $cmd]
  338. }
  339. } elseif {$namespace eq "::"} {
  340. return [list ::$cmd]
  341. } else {
  342. return [list ${namespace}::$cmd ::$cmd]
  343. }
  344. }
  345.  
  346.  
  347. proc auto_import {pattern} {
  348. global auto_index
  349.  
  350.  
  351. if {![string match *::* $pattern]} {
  352. return
  353. }
  354.  
  355. set ns [uplevel 1 [list ::namespace current]]
  356. set patternList [auto_qualify $pattern $ns]
  357.  
  358. auto_load_index
  359.  
  360. foreach pattern $patternList {
  361. foreach name [array names auto_index $pattern] {
  362. if {([namespace which -command $name] eq "")
  363. && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
  364. namespace eval :: $auto_index($name)
  365. }
  366. }
  367. }
  368. }
  369.  
  370.  
  371. if {$tcl_platform(platform) eq "windows"} {
  372. proc auto_execok name {
  373. global auto_execs env tcl_platform
  374.  
  375. if {[info exists auto_execs($name)]} {
  376. return $auto_execs($name)
  377. }
  378. set auto_execs($name) ""
  379.  
  380. set shellBuiltins [list cls copy date del erase dir echo mkdir  md rename ren rmdir rd time type ver vol]
  381. if {$tcl_platform(os) eq "Windows NT"} {
  382. lappend shellBuiltins "start"
  383. }
  384. if {[info exists env(PATHEXT)]} {
  385. set execExtensions [split ";$env(PATHEXT)" ";"]
  386. } else {
  387. set execExtensions [list {} .com .exe .bat]
  388. }
  389.  
  390. if {[lsearch -exact $shellBuiltins $name] != -1} {
  391. set cmd $env(COMSPEC)
  392. if {[file exists $cmd]} {
  393. set cmd [file attributes $cmd -shortname]
  394. }
  395. return [set auto_execs($name) [list $cmd /c $name]]
  396. }
  397.  
  398. if {[llength [file split $name]] != 1} {
  399. foreach ext $execExtensions {
  400. set file ${name}${ext}
  401. if {[file exists $file] && ![file isdirectory $file]} {
  402. return [set auto_execs($name) [list $file]]
  403. }
  404. }
  405. return ""
  406. }
  407.  
  408. set path "[file dirname [info nameof]];.;"
  409. if {[info exists env(WINDIR)]} {
  410. set windir $env(WINDIR)
  411. }
  412. if {[info exists windir]} {
  413. if {$tcl_platform(os) eq "Windows NT"} {
  414. append path "$windir/system32;"
  415. }
  416. append path "$windir/system;$windir;"
  417. }
  418.  
  419. foreach var {PATH Path path} {
  420. if {[info exists env($var)]} {
  421. append path ";$env($var)"
  422. }
  423. }
  424.  
  425. foreach dir [split $path {;}] {
  426. if {[info exists checked($dir)] || $dir eq {}} { continue }
  427. set checked($dir) {}
  428. foreach ext $execExtensions {
  429. set file [file join $dir ${name}${ext}]
  430. if {[file exists $file] && ![file isdirectory $file]} {
  431. return [set auto_execs($name) [list $file]]
  432. }
  433. }
  434. }
  435. return ""
  436. }
  437.  
  438. } else {
  439. proc auto_execok name {
  440. global auto_execs env
  441.  
  442. if {[info exists auto_execs($name)]} {
  443. return $auto_execs($name)
  444. }
  445. set auto_execs($name) ""
  446. if {[llength [file split $name]] != 1} {
  447. if {[file executable $name] && ![file isdirectory $name]} {
  448. set auto_execs($name) [list $name]
  449. }
  450. return $auto_execs($name)
  451. }
  452. foreach dir [split $env(PATH) :] {
  453. if {$dir eq ""} {
  454. set dir .
  455. }
  456. set file [file join $dir $name]
  457. if {[file executable $file] && ![file isdirectory $file]} {
  458. set auto_execs($name) [list $file]
  459. return $auto_execs($name)
  460. }
  461. }
  462. return ""
  463. }
  464.  
  465. }
  466.  
  467. proc tcl::CopyDirectory {action src dest} {
  468. set nsrc [file normalize $src]
  469. set ndest [file normalize $dest]
  470. if {$action eq "renaming"} {
  471. if {[lsearch -exact [file volumes] $nsrc] != -1} {
  472. return -code error "error $action \"$src\" to \"$dest\": trying to rename a volume or move a directory into itself"
  473. }
  474. }
  475. if {[file exists $dest]} {
  476. if {$nsrc eq $ndest} {
  477. return -code error "error $action \"$src\" to \"$dest\": trying to rename a volume or move a directory into itself"
  478. }
  479. if {$action eq "copying"} {
  480. return -code error "error $action \"$src\" to \"$dest\": file already exists"
  481. } else {
  482. set existing [glob -nocomplain -directory $dest * .*]
  483. eval [linsert  [glob -nocomplain -directory $dest -type hidden * .*] 0  lappend existing]
  484. foreach s $existing {
  485. if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
  486. return -code error "error $action \"$src\" to \"$dest\": file already exists"
  487. }
  488. }
  489. }
  490. } else {
  491. if {[string first $nsrc $ndest] != -1} {
  492. set srclen [expr {[llength [file split $nsrc]] -1}]
  493. set ndest [lindex [file split $ndest] $srclen]
  494. if {$ndest eq [file tail $nsrc]} {
  495. return -code error "error $action \"$src\" to \"$dest\": trying to rename a volume or move a directory into itself"
  496. }
  497. }
  498. file mkdir $dest
  499. }
  500. set filelist [concat [glob -nocomplain -directory $src *]  [glob -nocomplain -directory $src -types hidden *]]
  501.  
  502. foreach s [lsort -unique $filelist] {
  503. if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
  504. file copy $s [file join $dest [file tail $s]]
  505. }
  506. }
  507. return
  508. }
  509.